home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / 4th86_v4.zip / SHARPS.4TH < prev    next >
Text File  |  1994-01-01  |  6KB  |  153 lines
  1. ( forget strt
  2. : strt ; )
  3. off printload 
  4. unsplit
  5.  
  6. ( ************************************************* )
  7. ( * double precision formatted output routines.   * )
  8. ( * file sharps.4th        December 2nd. 1993     * )
  9. ( * these programs are modeled after the fig-forth* )
  10. ( * routines that perform the same function.      * )
  11. ( * and are adapted  from the original CP/M80     * )
  12. ( * source code                                   * )
  13. ( ************************************************* )
  14.  
  15. 30                      ( size of string buffer containing the number)
  16. dup block #buffer       ( string buffer)
  17. '' #buffer + const #endbuf ( address of end )
  18.  
  19. 2 block #inpoint        ( input pointer)
  20. 1 block #sign           ( sign flag)
  21.  
  22. : #putbyte              ( put the byte at tos in the buffer)
  23.   #inpoint @ 1 -        ( new input pointer)
  24.   dup #buffer = 
  25.  
  26.        if                    ( do we have overflow?)
  27.        │  #endbuf 1 - swap 
  28.        │    do 
  29.        │    │  "*" i b! 
  30.        │    loop   ( fill buffer with stars.)
  31.        │  drop               ( discard the character)
  32.        else                  ( if no overflow, update pointer and store char.)
  33.        │  dup #inpoint ! b!
  34.        then
  35.   ;                          ( end of #putbyte.)
  36.  
  37. : <#                    ( begin a format operation)
  38.   #endbuf #inpoint !    ( input pointer is past end of buffer.)
  39.     ,dup ,0 ,< 
  40.        if               ( test the sign of the number)
  41.        │   ,-1*         ( negate the number) 
  42.        │   1            ( sign=1)
  43.        else
  44.        │   0            ( sign=0)
  45.        then
  46.      #sign b!           ( save the sign) 
  47.   ;                     ( end of <# )
  48.  
  49. : #                         ( convert one digit into the buffer)
  50.      ,10 ,/mod ,swap single ( convert the digit)
  51.       "0" +                 ( make it ascii) 
  52.       #putbyte              ( put it in the buffer)
  53.   ;                         ( end of # )
  54.  
  55. : #s                     ( convert the digits until ,tos is zero)
  56.      begin               ( do until tos=0 )
  57.      │    #              ( convert a digit)
  58.      │    ,dup ,0=       ( test tos)
  59.      end ;               ( end of #s )
  60.  
  61. : #.                    ( put in a decimal point and convert the 
  62. 2
  63.                                                 rest of the digits)
  64.   "." #putbyte #s ;     ( end of #. )
  65.  
  66. : #-                    ( put in an optional sign field )
  67.       #sign b@ 
  68.        
  69.   if 
  70.   │   "-" #putbyte 
  71.   then ;
  72.  
  73. : #+                    ( put in a required sign field )
  74.   #sign b@ if "-" else "+" then #putbyte ;
  75.  
  76. : #>                    ( terminate the formatting operation, return the addr.)
  77.                         ( of the beginning of the string representing the     )
  78.                         ( field.  on entry, tos=the field width, ,nos is ,0   )
  79.   #endbuf #inpoint @ - 1 + ( current field size + 1.)
  80.   do                    ( note: field size<current makes no spaces )
  81.   │    20h #putbyte
  82.   loop                  ( field is now correct width)
  83.   ,drop                 ( discard the number being converted)
  84.   #endbuf #inpoint @ -  ( length of string)
  85.   #inpoint @ 1 - swap over b! ( store in string)
  86.                         ( note: tos points to the length byte of the string)
  87.   ;                     ( end of #> )
  88.  
  89. ( ----------------------------------------------------- )
  90.  
  91. ( 5 JUNE 1982  Donald M. Ramsey )
  92.  
  93. ( This extension [ original June 1982 by Donald M. Ramsey ]  demonstrates the  
  94.  use of the words in file SHARPS.4TH for printing single and double precision 
  95.  numbers in a specified field width with and without sign.  )
  96.  
  97.  
  98. 2 block fw              ( VARIABLE FIELD WIDTH WILL BE USED)
  99. 7 fw !                  ( use field width of seven for now)
  100.  
  101. : s.#                   ( single precision number without decimal pt or sign)
  102.      double             ( convert number to double precision)
  103.      <# #S FW @ #>      ( convert number to string within #BUFFER)
  104.   ."                    ( print contents of #BUFFER)
  105. ; ( ----------------------------- )
  106.  
  107. : d.#                   ( double precision number w/o decimal pt or sign)
  108.      <# #S FW @ #> ."
  109. ; ( ----------------------------- )
  110.  
  111. : s2.#          ( single precision with 2 decimal places and forced sign)
  112.      double
  113.      <# # # #. #S #+ FW @ #> ."
  114.                 ( note that the field specifier <#...#> works backwards, ie.
  115.                     you specify output starting with right end of number)
  116. ; ( ----------------------------- )
  117.  
  118. : D3.#          ( double precision with 3 decimal places and optional sign)
  119.      <# # # # #. #S #- FW @ #> ."
  120. ; ( ----------------------------- )
  121.  
  122. : DN.#          ( double prec. with field width passed on stack)
  123.      <# #S #- 3 pick #> ." drop
  124. ; ( ----------------------------- )
  125.  
  126. cls
  127.  
  128. " print a single precision number rt justified in seven  char field " ."
  129.          crlf 123 S.# "        <= 123 S.# " ."   crlf
  130.  
  131. crlf " print a double precision number " ."
  132.          crlf 12345, D.# "     <= 12345, D.#  " ." crlf
  133.  
  134. crlf " print a single precision number with 2 places to rt of decimal pt " ."
  135. crlf "                             put a sign in number even if positive " ."
  136.      crlf 123 S2.# "     <= 123 S2.#  " ." 
  137.      crlf -123 S2.# "     <= -123 S2.#  " ." crlf
  138.  
  139. crlf " print a double precision number with 3 places to rt " ."
  140. crlf "                            put a sign in number if it is negative " ."
  141.          crlf 1234, D3.# "     <= 1234, D3.# " ." 
  142.          crlf -1234, D3.# "     <= -1234, D3.# " ." crlf
  143.  
  144. crlf " print a double prec. number with field width = n " ." crlf
  145.  
  146.       crlf 10 123, DN.# "   <= 10 123, DN.# ( n = 10 )  " ." 
  147.  
  148.           crlf   5  -7154,  DN.#   "        <= 5  -7154,  DN.# ( n = 5 ) " ." 
  149. crlf
  150.  
  151.                 ( change FW to other field widths and try experimenting! )
  152.  
  153.